perm filename ARMY.SAI[CMS,LCS] blob
sn#109260 filedate 1974-07-03 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00004 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002
C00004 00003
C00009 00004 SUBR COMND
C00013 ENDMK
C⊗;
BEGIN "ARMY"
REQUIRE "GEOMES.HDR[GEM,HE]" SOURCE_FILE;
DEFINE α="COMMENT";
DEFINE π="3.1415927";
DEFINE SUBR="SIMPLE PROCEDURE";
DEFINE ISUBR="SIMPLE INTEGER PROCEDURE";
DEFINE THRU="STEP 1 UNTIL";
DEFINE ⊂="BEGIN";
DEFINE ⊃="END";
EXTERNAL SIMPLE REAL PROCEDURE ACOS(REAL W);
INTEGER FRATE,CHR,GRAV,TAKE,IP,X,Y,Z;
REAL NR,NT;STRING STR;
SUBR INIT; α INITIALIZATION;
BEGIN "INIT"
MKUNIV;GEODPY;
X ← 0;Y ← 3;Z ← 6;
IP ← 0;TAKE ← 1;
FRATE ← 20;
OUTSTR(" FRATE =");STR ← INCHWL;
IF LENGTH(STR)≠0 THEN FRATE ← INTSCAN(STR,CHR);
NT ← 1.0/FRATE;NR ← NT*π;GRAV ← 32*NT;
END "INIT";
SIMPLE REAL PROCEDURE ANGL(INTEGER B1,A1,B2,A2);
BEGIN "ANGL"
REAL ANG;
B1 ← A1+LOCOR(B1);
B2 ← A2+LOCOR(B2);
ANG ← ACOS(IX(B1)*IX(B2)+IX(B1+1)*
IX(B2+1)+IX(B1+2)*IX(B2+2));
RETURN(ANG);
END "ANGL";
ISUBR BUMP(INTEGER B1,B2,AX1,AX2;REAL MINA,MAXA,SP);
BEGIN "BUMP"
INTEGER STP;
REAL ANG;
IF B1<0 THEN B1 ← -B1;
ANG ← SP+ANGL(B1,AX1,B2,AX2);
IF ANG<MINA∨ANG>MAXA THEN STP ← -1
ELSE STP ← 0;
RETURN(STP);
END "BUMP";
ISUBR BEND(INTEGER BAC,BD1,BD2,AR1,AR2,AR3;REAL MN,MX,SP);
BEGIN "BEND"
INTEGER PAST;
REAL RO,RX,RY,RZ;
SP ← NR*SP;RO ← SP;
IF BAC=2 THEN SP ← -SP;
IF BUMP(BD1,BD2,AR2,AR3,MN,MX,SP) THEN BEGIN
PAST ← -1;
IF BAC THEN BEGIN
IF BAC>0 THEN RETURN(PAST);
RO ← -RO;
END;
END
ELSE PAST ← 0;
RX ← RY ← RZ ← 0;
CASE AR1 OF ⊂ [0] RX ← RO;[3] RY ← RO;[6] RZ ← RO ⊃;
ROTATE(BD1,RX,RY,RZ);
RETURN(PAST);
END "BEND";
SUBR PLOP;
BEGIN "PLOP"
IF TAKE>0 THEN ⊂ IF TAKE>1 THEN SHOW2(0,1)
ELSE GEODPY;RETURN;⊃;
IF TAKE<-1 THEN SHOW2(0,1) ELSE GEODPY;
IP ← IP+1;
OUTSTR(" FRAME "&CVS(IP));PLOTO("FRM."&CVS(IP));
END "PLOP";
SUBR COMND;
BEGIN "COMND"
INTEGER GIRL,GIR2,YES,NO,TWO,LC;
REAL DG4,DG5,DG7,DG11,FAST,SLOW,FASTER,TS;
SUBR GAPO;
BEGIN "GAPO"
TRANSL(GIRL,0,0,TS);PLOP;
END "GAPO";
SUBR NOD(INTEGER B1,UPDOW;REFERENCE REAL SP);
BEGIN "NOD"
INTEGER A1,A2,A3,HD;
REAL MN,MA;
HD ← CCW(CCW(CCW(CCW(B1))));
IF UPDOW THEN ⊂ A1 ← X;A2 ← Z;A3 ← Y;
MN ← DG7;MA ← DG11;⊃
ELSE ⊂ A1 ← Y;A2 ← X;A3 ← Z;MN ← DG4;MA ← DG5;⊃;
IF BEND(YES,-HD,B1,A1,A2,A3,MN,MA,SP) THEN SP ← -SP;
END "NOD";
ISUBR SALUTE(INTEGER B1;REAL SP);
BEGIN "SALUTE"
INTEGER I,RS,RA,T1;
REAL MI,MX,MB;
RS ← B1;
FOR I←1 THRU 18 DO RS ← CCW(RS);
RA ← CCW(RS);
MB ← π/1.7;MX ← π/2;I ← 3;SP ← -SP;
MI ← 0;
I ← I+BEND(TWO,-RA,RS,X,Y,Y,MI,MB,SP);
I ← I+BEND(TWO,-RS,B1,Z,Y,Y,MI,MX,SP);
I ← I+BEND(TWO,-RS,B1,X,Z,Z,MI,MX,SP);
RETURN(I);
END "SALUTE";
SUBR SCENE;
BEGIN "SCENE"
INTEGER IT,I2;
REAL SP1,SP2;
SP1 ← SP2 ← FASTER;
FOR IT←1 THRU 10 DO
⊂ NOD(GIRL,YES,SLOW);
NOD(GIR2,NO,FAST);GAPO;⊃;
WHILE TRUE DO
⊂ IT ← SALUTE(GIRL,SP1);
IF IT=0 THEN ⊂ IF SP1<0 THEN RETURN;SP1 ← -SP1;⊃;
I2 ← SALUTE(GIR2,SP2);
IF I2=0 THEN ⊂ IF SP2<0 THEN RETURN;SP2 ← -SP2;⊃;
IF IT+I2 THEN GAPO;⊃;
END "SCENE";
GIRL←INB3D("LYN[CMS,LCS]");
GIR2←INB3D("LYN[CMS,LCS]");
GEODPY;
NO ← 0;YES ← -1;FAST ← .8;SLOW ← .5;
FASTER ← .8;TS ← NT/3;TWO ← 2;
DG4 ← π/4;DG5 ← DG4*3;
DG7 ← π/2.5;DG11 ← π/1.8;
WHILE TRUE DO
BEGIN
LC ← INCHRW;
IF LC="P" THEN ⊂ TAKE ← -2;PLOP;⊃;
IF LC="S" THEN SCENE;
IF LC="G" THEN GEOMED;
END;
END "COMND";
α MAIN EXECUTION;
OUTSTR(12&12&12&12&12);
INIT;
COMND;
END "ARMY";